home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 24 / CU Amiga Magazine's Super CD-ROM 24 (1998)(EMAP Images)(GB)(Track 1 of 2)[!][issue 1998-07].iso / CUCD / Programming / SWI / source / boot / qlf.pl < prev    next >
Encoding:
Text File  |  1995-11-01  |  2.6 KB  |  120 lines
  1. /*  $Id: qlf.pl,v 1.4 1995/11/01 10:45:50 jan Exp $
  2.  
  3.     Designed and implemented by Jan Wielemaker
  4.     E-mail: jan@swi.psy.uva.nl
  5.  
  6.     Copyright (C) 1995 University of Amsterdam. All rights reserved.
  7. */
  8.  
  9. :- module($qlf,
  10.       [ qcompile/1,        % +File
  11.         qload/1,        % +File
  12.         $qload_file/6    % +Path, +Module, +Import, +IsModule, -Ac, -LM
  13.       ]).
  14.  
  15.  
  16.          /*******************************
  17.          *       COMPILATION        *
  18.          *******************************/
  19.  
  20. :- module_transparent
  21.     qcompile/1,
  22.     qload/1,
  23.     qload/2,
  24.     yesno/2.
  25.  
  26.  
  27. qcompile([]) :- !.
  28. qcompile([H|T]) :- !,
  29.     qcompile(H),
  30.     qcompile(T).
  31. qcompile(File) :-
  32.     $strip_module(File, Module, FileName),
  33.     absolute_file_name(FileName,
  34.                [ extensions(['.pl', '']),
  35.                  access(read)
  36.                ], Absolute), !,
  37.     remove_suffix(Absolute, '.pl', ABase),
  38.     ensure_suffix(ABase, '.qlf', Qlf),
  39.     $qlf_open(Qlf),
  40.     flag($compiling, Old, qlf),
  41.     $set_source_module(OldModule, Module), % avoid this in the module!
  42.     yesno(consult(Module:Absolute), Yes),
  43.     $set_source_module(_, OldModule),
  44.     Yes,
  45.     flag($compiling, _, Old),
  46.     $qlf_close.
  47.  
  48. remove_suffix(F, S, B) :-
  49.     concat(B, S, F), !.
  50. remove_suffix(F, _, F).
  51.  
  52. ensure_suffix(X, S, X) :-
  53.     concat(_, S, X), !.
  54. ensure_suffix(X, S, XS) :-
  55.     concat(X, S, XS).
  56.  
  57. yesno(G, Yes) :-
  58.     (   G
  59.     ->  Yes = true
  60.     ;   Yes = fail
  61.     ).
  62.  
  63.     
  64.          /*******************************
  65.          *          LOADING        *
  66.          *******************************/
  67.  
  68. qload([]) :- !.
  69. qload([H|T]) :- !,
  70.     qload(H),
  71.     qload(T).
  72. qload(File) :-
  73.     qload(File, [verbose = true]).
  74.  
  75. qload(File, Options) :-
  76.     statistics(heapused, OldHeap),
  77.     statistics(cputime, OldTime),
  78.  
  79.     $strip_module(File, Module, FileName),
  80.     absolute_file_name(FileName,
  81.                [ extensions(['.qlf', '']),
  82.                  access(read)
  83.                ], Absolute), !,
  84.     $qlf_load(Module:Absolute, LoadedModule),
  85.     (   atom(LoadedModule)
  86.     ->  (   memberchk(import = Import, Options)
  87.         ->    true
  88.         ;    Import = all
  89.         ),
  90.         $import_list(Module, LoadedModule, Import)
  91.     ;   true
  92.     ),
  93.  
  94.     (   memberchk(verbose=true, Options)
  95.     ->  statistics(heapused, Heap),
  96.         statistics(cputime, Time),
  97.         HeapUsed is Heap - OldHeap,
  98.         TimeUsed is Time - OldTime,
  99.         $confirm_file(FileName, Absolute, ConfirmFile),
  100.         $confirm_module(LoadedModule, ConfirmModule),
  101.  
  102.         $ttyformat('~N~w loaded~w, ~2f sec, ~D bytes.~n',
  103.                [ConfirmFile, ConfirmModule, TimeUsed, HeapUsed])
  104.     ;   true
  105.     ).
  106.  
  107.  
  108. $qload_file(File, Module, Import, IsModule, loaded, LoadedModule) :-
  109.     $qlf_load(Module:File, LoadedModule),
  110.     check_is_module(IsModule, LoadedModule, File),
  111.     (   atom(LoadedModule)
  112.     ->  $import_list(Module, LoadedModule, Import)
  113.     ;   true
  114.     ).
  115.     
  116.  
  117. check_is_module(true, 0, File) :- !,
  118.     $warning('use_module: ~w is not a module file', [File]).
  119. check_is_module(_, _, _).
  120.